00100	COMMENT ⊗   VALID 00002 PAGES
00200	C REC  PAGE   DESCRIPTION
00300	C00001 00001
00400	C00002 00002		SUBROUTINE WRTPAG
00500	C00017 ENDMK
00600	C⊗;
     

00100		SUBROUTINE WRTPAG
00200		DATA SLSP/12.0/
00300		COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
00400		1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2 
00500		1 /SF/KL,RT,KP,SIZE,NAMX,EXT /IPG/IPG
00600		1 ,JPG,BRACK(0/7),RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(0/7) 
00700		1 /RSP/KNM(1) /ENDL/ENDLN,N,NAME,NMPG,T /KBAR/KBAR(515)
00800	 	1 /RCLF/KK,CL,KW,ITEM,RSTAFF,SN,YN,RNAM,RNAM2,ITR
00900		COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
01000		COMMON/STF/RSTFAC(0/7),RSTJ2 /IVV/IV(1) /KNUM/KNUM
01100		COMMON /POSI/STFF(0/7),JJ2,JPQ /LLL/L,LL,I,RXQ
01200		1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1) /NBAR/NBAR(1)
01300		1/BRJ/JTOT,TURN,NB,DSK,PGLNTH
01400		DIMENSION ENDSTF(450)
01500	C  ENDSTF AND ENDPTR FOR CARRYING STUFF FROM ONE LINE TO THE NEXT.
01600		EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R7,RQ(5))
01700		1,(R8,RQ(6)),(LCNT,IV(45)),(NDPY,IV(46)),(ENDSTF,KBAR(4))
01800		DATA VERT/0.045/
01900	C VERT IS BASIC VERTICAL UNIT SIZE IN INCHES
02000		IF(MPG.NE.0)GO TO 4
02100		DO 1 K=1,100
02200	1	IF(NBAR(K).EQ.0)GO TO 3
02300	3	MPG=K-1
02400	C SETS NUMB. OF LINES ON FIRST PAGE
02500	4	IF(SPG.EQ.0)SPG=PGLNTH/MPG
02600		RS=SIZE*17.5
02700		HX=0
02800	CC	RA=(RSTJ2*SIZE)/RPSZ(1)
02900		RA=RPSZ(JPG)
03000	C SAVE SIZE OF TOP STAFF FOR LATER
03100		DO 141 K=1,JPG
03200		RB=RSTNUM(K)
03300	C  ADJUSTS DIST. BETWEEN STAVES DEPENDING ON SIZE FACTOR.
03400		RHGT(K)=RHGT(K)+RB*(RS-17.5)
03500	CC	RPSZ(K)=RPSZ(K)*RA
03600	141	RPSZ(K)=RPSZ(K)*SIZE
03700	CC141	HX=HX+(RHGT(K)+17.5)*RPSZ(K)*RT
03800	CZZ	HX=(17.5*RSTNUM(JPG)+17.5)*VERT
03900		HX=(17.5*RSTNUM(JPG)+17.5+RHGT(JPG)*RA)*VERT
04000	C HX=TOTAL HEIGHT IN INCHES. THIS ASSUMES RSTNUM(JPG) IS HIGHEST STAFF NUM.
04100	C ALSO ASSUMES HIGHEST STAFF NUM. IS REALLY ABOVE ALL OTHERS.
04200	143	IF(HX.LE.SPG)GO TO 140
04300		HX=SPG/HX
04400	C GET  THE FACTOR FOR SPACE BETWEEN STAVES
04500	CZZ	DO 142 K=1,LPG
04600	CZZ	RA=17.5*RSTNUM(K)
04700	CZZ142	RHGT(K)=RA*HX-RA
04800		RA=1/HX
04900		DO 142 K=1,JPG
05000		SP=RHGT(K)
05100		IF(SP)GO TO 1142
05200	C MULT +S * <1, -S * >1  TO REDUCE SIZE
05300		SP=SP*HX
05400		GO TO 142
05500	1142	SP=SP*RA
05600	142	RHGT(K)=SP
05700	CC142	RHGT(K)=(RA+RHGT(K))*HX-RA
05800	140	NPG=1
05900		NMPG='PAGEA'
06000		HORZ=96.
06100		IF(KNUM.GT.0)KNUM=KNUM-1
06200	C FOR PAGE NUMS.
06300		IF(MOD(KNUM,2).NE.0)HORZ=-HORZ
06400		RNUM=0.+KNUM
06500		LB=0
06600		ITR=LL
06700	C TRANSPOSE IS IN LL
06800		RA=0
06900		JEND=-1
07000		METR=1000
07100		CLEF=-99
07200		JSLUR=0
07300		LC=1
07400		KREAD=128
07500		SIG=CLEF
07600		HX=2
07700		KQ=1
07800		KPX=1
07900		CALL FILOUT
08000	C NAMQ AND NPG ARE SET IN FILOUT  
08100		SP=2.45
08200	C  DEFAULT VERT. SPACE UNITS
08300		ENDSTF(1)=0
08400		IF(N.EQ.0)GO TO 100
08500	C  SPACED OUT DEPENDING ON NUM OF LINES
08600		HX=N
08700		SP=SP+(HX-2.)*.11
08800	
08900	100	CALL FILEIN
09000	
09100	320	CALL STAVES
09200	CC	IF(IPG)GO TO 3000
09300		IF(NPG.NE.1)GO TO 3000
09400		RT=RSTNUM(JPG)
09500		RS=100.+HORZ
09600		HORZ=-HORZ
09700		RNUM=RNUM+1
09800	C ADDS PAGE NUMBER. SIZE(P6)=1.1  P7=3 SO PARTS PROG. WILL IGNORE IT.
09900		CALL STAFF(5.,10.,RS,28.,RNUM,1.1,3.0,0,0,0,0,0)
10000	3000	IF(ITR.NE.0)CALL TRNSP
10100		JPQ=KL
10200	
10300		NA=0
10400		KPT=1
10500		ENDSTF(1)=0
10600	C  LOOP STARTS HERE *******
10700	131	NA=NA+1
10800		KWDS(KP)=JPQ
10900		KP=KP+1
11000		R=CODEN(KPN,NA,Q,JK)
11100		RR=Q(JK+6)
11200		RS=Q(JK)
11300		IF(R.NE.5)GO TO 935
11400		R8=-1
11500		IF(RS.GE.6)R8=Q(JK+8)
11600		IF(RR)GO TO 735
11700		IF(RR.LE.Q(JK+3))RR=202.
11800		GO TO 235
11900	C CATCHES SLURS, TRILLS, 8VA, LINES THAT GO PAST END OF LINE.
12000	935	IF(R.EQ.7)GO TO 835
12100		IF(R.NE.44)GO TO 35
12200		R=R/11.
12300		Q(JK+1)=R
12400	C  INFOR FOR P9 AND L10 OF DASHES AND WIGGLES NOT KEPT YET!!!!!!!
12500		IF(RR.LT.Q(JK+3))GO TO 30
12600	C  NEEDED WHEN DATA ON LINE HAS BEEN EXPANDED, NOT CONTRACTED.
12700	835	R8=0
12800		R7=0
12900		IF(RS.GE.6)R8=Q(JK+8)
13000	235	IF(RR.LT.199.)GO TO 30
13100	C  P1,P2,P3,P4,P5,P6,P7,P8  ARE SAVED.
13200		RR=-1
13300	735	IF(RS.GE.5)R7=Q(JK+7)
13400		ENDSTF(KPT)=6
13500		ENDSTF(KPT+1)=R
13600		C=Q(JK+2)
13700		ENDSTF(KPT+2)=C
13800		ENDSTF(KPT+3)=1
13900		ENDSTF(KPT+4)=Q(JK+4)
14000		ENDSTF(KPT+5)=Q(JK+5)
14100		ENDSTF(KPT+7)=R7
14200		ENDSTF(KPT+8)=R8
14300	 	ENDSTF(KPT+6)=RR
14400	
14500	236	KPT=KPT+13
14600		ENDSTF(KPT)=0
14700		Q(JK+6)=202
14800		GO TO 30
14900	C*************
15000	35	IF(R.NE.2)GO TO 36
15100		IF(RS.EQ.7)GO TO 30
15200	C SKIP ALL THIS IF NEW CENTERING (P9 NOW HAS POS.)
15300		IF(RS.LT.6.)GO TO 30
15400	
15500		RR=RIGHT(NA,-1,JK)
15600		Q(JK+3)=RR-1.6*RSTJ2+(RIGHT(NA,1,JK)-RR)/2.
15700	C  FUNCTION 'RIGHT' FINDS ITEMS TO LFT AND RT OF REST FOR CENTERING.
15800	C CENTERS WHOLE REST
15900		GO TO 30
16000	36	IF(R.NE.3)GO TO 34
16100		CLEF=CLEFN(Q,JK)
16200		LL=Q(JK+2)
16300	C GETS CLEF FOR PAGE LAYOUT
16400		RCLEF(LL)=CLEF
16500		GO TO 30
16600	34	IF(R.NE.17)GO TO 37
16700		SIG=Q(JK+5)
16800		IF(ABS(SIG).GT.100.)SIG=-99
16900	C  DO NOT REPEAT KSIG MADE UP OF NATURALS.
17000	CXX	IF(Q(JK).GT.3)SIG=SIG+Q(JK+6)*100.
17100	CXX  CLEF # IN P6 WITH KEY SIGS.
17200	C  NEXT CHANGES CODE NUM BACK TO ORIGINAL
17300	37	IF(R.LT.33)GO TO 130
17400	38	Q(JK+1)=R/11.
17500		GO TO 30
17600	130	IF(Q(JK+3).LT.199)GO TO 30
17700		IF(R.NE.18)GO TO 30
17800		KKK=K+1
17900		R3=9
18000		IF(SIG.NE.-99)R3=14
18100		KK=JK
18200	435	LL=KPN(KKK)
18300	C  WDCNT,P1,P2,P3,P4,P5,P6,P7,P8
18400		ENDSTF(KPT)=Q(KK)
18500		ENDSTF(KPT+1)=R
18600		ENDSTF(KPT+2)=Q(KK+2)
18700		ENDSTF(KPT+3)=R3
18800		DO 535 JJ2=4,12
18900	535	ENDSTF(KPT+JJ2)=Q(KK+JJ2)
19000		KPT=KPT+13
19100		ENDSTF(KPT)=0
19200	
19300		RS=Q(LL+1)
19400		IF(RS.LE.4)GO TO 30
19500		R4=Q(LL+2)
19600	C  SAVE THE STAFF NUM. IN R4
19700		IF(RS.NE.18)GO TO 7011
19800	335	R3=R3+6
19900		KK=LL
20000		KKK=KKK+1
20100		GO TO 435
20200	7011	RS=CODEN(KPN,KKK+1,Q,LL)
20300		IF(RS.LE.4)GO TO 30
20400		IF(Q(LL+2).NE.R4)GO TO 30
20500		IF(RS.EQ.18)GO TO 335
20600	30	JPQ=KPN(NA+1)-KPN(NA)+JPQ
20700		IF(NA.LT.I)GO TO 131
20800	C  END OF LOOP ****************
20900	
21000		CALL PSHFT(I)
21100	C NEXT GETS RID OF USELESS SLURS (NO LENGTH)
21200		K=1
21300	441	IF(CODEN(KWDS,K,RN,J).NE.5)GO TO 41
21400		IF(ABS(RN(J+6)-RN(J+3)).GT..2)GO TO 41
21500	C NEXT DELETES THE SLUR
21600		LL=RN(J)+3
21700		DO 241 NA=J,JPQ
21800	241	RN(NA)=RN(NA+LL)
21900		JPQ=JPQ-LL
22000	CCC	LL=KPN(K+2)-KPN(K+1)-LL
22100	  	I=I-1
22200		KP=KP-1
22300		DO 341 NA=K+1,KP
22400	341	KWDS(NA)=KWDS(NA+1)-LL
22500		GO TO 441
22600	41	K=K+1
22700		IF(K.LT.KP-1)GO TO 441
22800	
22900		RS=-1
23000	C -1 FOR ALL STAVES AT ONCE IN GETPTS.
23100	CCC	RS=RT
23200		LL='J'
23300		R4=0
23400		R5=200
23500		NA=L
23600		L=KP-1 
23700		DO 146 K=0,JPG-1
23800	146	RSTFAC(K)=RSTFAC(K)*SIZE
23900	C GETS PROPER SIZE FACTORS FOR JUSTIFY SUBR.
24000		CALL PTMOVE(RN,KWDS)
24100	
24200	C  START LAST LOOP *******
24300	CC	DO 47 JJ2=1,KP
24400	CC	LL=KWDS(JJ2)
24500	CC	AA=RN(LL+1)
24600	CC	IF(AA.NE.10.AND.AA.NE.16)GO TO 1047
24700	CN	IF(AA.NE.10.AND.AA.NE.16)GO TO 347
24800	C***** SKIP NEXT FOR NOW ******* 1/28/78
24900	CC	GO TO 47
25000	CC	DO 147 NN=JJ2+1,KP
25100	CC	MM=KWDS(NN)
25200	CC	IF(RN(MM+1).NE.16)GO TO 147
25300	C  FOUND THE NEXT TEXT AFTER TEXT OR NUMB.
25400	CC	IF(RN(MM).EQ.8)GO TO 47
25500	C  JUMP IF POS. IS ALREADY TAKEN CARE OF.
25600	CC	IF(AA.EQ.10)GO TO 247
25700	C NEXT FOR TEXT FOLLOWING TEXT
25800	CC	IF(ABS(RN(MM+4)-RN(LL+4)).GE.4)GO TO 47
25900	C JUMP IF ON DIFF. VERT. PLANE.
26000	CC	AA=(RN(LL+9)+4.)*RSTJ2*RN(LL+5)+RN(LL+3)
26100	C  SETS MINIMUM SPACE.
26200	CC	IF(RN(MM+3).LT.AA)RN(MM+3)=AA
26300	CC	GO TO 47
26400	CC247	IF(ABS(RN(MM+4)-RN(LL+4)).GT.6)GO TO 47
26500	C  CHECKS VERT. POS.
26600	CC	AA=RN(LL+4)+7
26700	CC	IF(RN(MM+4)-AA.LT.0)RN(MM+4)=AA
26800	C  MOVE WORD TO RIGHT OF NUMBER IF IT WAS TOO CLOSE
26900	CC	GO TO 47
27000	CC147	CONTINUE
27100	CC	GO TO 47
27200	CC1047	IF(AA.NE.6)GO TO 47
27300	CC	IF(RN(LL).LT.7)GO TO 47
27400	CC	IF(RN(LL+9).GT.200.)RN(LL+9)=0
27500	C ********** FIX THIS IN GETPTS, MOVER.  IT SHOULDN'T MOVE P9 ALWAYS.
27600	CC47	CONTINUE
27700	
27800	2	KWDS(KP)=JPQ
27900	CP	J=1
28000		IF(KP.GE.300.OR.JPQ.GE.2500)TYPE 20,KP,JPQ
28100		JJ2=KP+1
28200	C  WRITES 1 EXTRA WORD
28300	CP	JPQ=KB
28400	
28500		DO 12 K=1,KP
28600	CC	N=KWDS(K)
28700	CC	R=RN(N+1)
28800		R=CODEN(KWDS,K,RN,N)
28900		IF(R.LE.2)GO TO 22
29000	C  ONCE IT FINDS A REST OR NOTE IT MUST HAVE GONE TOO FAR.
29100		IF(R.GT.7)GO TO 12
29200	 	IF(R.EQ.5)GO TO 52
29300		IF(R.NE.4)GO TO 62
29400		IF(RN(N).GE.4)GO TO 52
29500	62	IF(R.NE.7)GO TO 12
29600	52	A=RN(N+6)
29700	C J HAS NOTE COUNT TO FIND POS OF RIGHT END OF SLUR.
29800		IF(A.GE.0)GO TO 12
29900		J=A
30000		IF(J.EQ.0)J=-1
30100		B=RN(N+2)
30200	C  B=STAFF NUM.
30300		JJ=0
30400	
30500		DO 32 KK=K+1,KP
30600	CC	NN=KWDS(KK)
30700	CC	A=RN(NN+1)
30800		A=CODEN(KWDS,KK,RN,NN)
30900		IF(A.NE.1)GO TO 32
31000		IF(B.NE.RN(NN+2))GO TO 32
31100		D=RN(NN+3)
31200		JJ=JJ-1
31300		IF(J.NE.JJ)GO TO 42
31400		RN(N+6)=D+(D-A)*(RN(N+6)-J)
31500	C FOUND NOTE FOR POSITION.
31600		GO TO 12
31700	42	A=D
31800	32	CONTINUE
31900	12	CONTINUE
32000		
32100	22	CALL PUTEXT(NAMX,EXT)
32200		LCNT=0
32300	CC	NDPY=0
32400		RSTFAC(99)=0
32500	C  MUST BE 0 IN MS TO MAKE DISPLAY
32600		CALL EXTOUT(RSTFAC,128)
32700		CALL EXTOUT(KWDS,JJ2)
32800		CALL EXTOUT(RN,JPQ)
32900		TYPE 101,NAMX,EXT
33000		NAMX=NAMX+2
33100	CC	IF(IPG)GO TO 6011
33200		NPG=NPG+1
33300		IF(NBAR(LC).NE.0)GO TO 220
33400		KK=LC+1
33500		IF(NBAR(KK).EQ.0)GO TO 220
33600	CHECK FOR ZEROS WHICH ARE PAGE MARKS.
33700		LC=LC+1
33800	221	KK=KK+1
33900		IF(NBAR(KK).NE.0)GO TO 221
34000	C  FIND NEW MPG
34100		MPG=KK-LC
34200		NPG=1000
34300		SPG=10./MPG
34400		JEND=0
34500	C RESET ABOVE
34600	220	IF(NPG.LE.MPG)GO TO 6011
34700		NPG=1
34800	C RESET, UPDATE FILENAMES
34900		NAMX=NAMZ+256
35000		NAMZ=NAMX
35100	6011	NAMQ=NAMX
35200		CALL FINEXT
35300		GO TO 100
35400	C IPG=1  = GO BACK TO TRONLY INSTEAD
35500	101	FORMAT(1XA5,'.',A3)
35600	20	FORMAT(' TOO MUCH DATA!!! ',I3,'/300',I5,'/2500')
35700		END